home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
45 Great Windows Utilities 7
/
45 Great Windows Utilities Volume 7 MOJO-411 (Mojo Software).iso
/
dsize
/
dsize.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-06-23
|
19KB
|
692 lines
{DSize - 1.0 Program Copyright (C) Doug Overmyer 6/22/91}
program DSize;
{$S-}{$I-}
{$R DSIZE.RES}
uses WinTypes, WinProcs, WinDos, Strings, WObjects,StdDlgs;
const
id_But1 = 201;
id_But2 = 202;
id_But3 = 203;
id_But4 = 204;
id_Lb1 = 301;
id_lb2 = 302;
id_St1 = 401;
id_St2 = 402;
id_St3 = 403;
id_St4 = 404;
id_st5 = 405;
{******************************************************************}
{ Types }
{******************************************************************}
type
TDSApplication = object(TApplication)
procedure InitMainWindow;virtual;
end;
type
PStackItem = ^TStackItem;
TStackItem = object(TObject)
StackItem:PChar;
constructor Init(NewItem:PChar);
destructor Done;virtual;
end;
type
PStack = ^TStack;
TStack = object(TCollection)
procedure Push(Item:Pointer);virtual;
function Pop:Pointer;virtual;
end;
PDSDialog = ^TDSDialog;
TDSDialog = object(TDialog)
TheDrive: Array[0..3] of Char;
procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
procedure IDLb1(var Msg:TMessage);virtual id_First+id_Lb1;
end;
{TTextStream}
type
PTextStream = ^TTextStream ;
TTextStream = object(TBufStream)
CharsToRead : LongInt;
CharsRead : LongInt;
ARecord :PChar;
constructor Init(FileName:PChar;Mode,Size:Word);
destructor Done;virtual;
function GetNext:PChar;virtual;
function WriteNext(szARecord:PChar):integer;virtual;
function WriteEOF:integer;virtual;
function IsEOF:Boolean;virtual;
function GetPctDone:Integer;
end;
type
PDirRec = ^TDirRec;
TDirRec = object(TObject)
PathName:PChar;
DirSize:PChar;
constructor Init(NewPathName:PChar;NewDirSize:PChar);
destructor Done;virtual;
end;
PDSCollection = ^TDSCollection;
TDSCollection = object(TSortedCollection)
Maxpath:Integer;
constructor Init(ALimit,ADelta:Integer);
function KeyOf(Item:Pointer):Pointer;virtual;
function Compare(Key1,Key2:Pointer):Integer;virtual;
end;
{DSWindow}
PDSWindow = ^TDSWindow;
TDSWindow = object(TWindow)
Editor:PEdit;
Editor1:PListBox;
TheIcon:HIcon;
TheButton,TheLogo:HBitmap;{About}
TheCollection:PDSCollection;
Bn1,Bn2,Bn3,Bn4 : PButton;
Dlg1 : PDSDialog;
St1,St2,St3,St4:PStatic;
constructor Init(AParent:PWindowsObject;ATitle:PChar);
destructor Done;virtual;
procedure SetupWindow;virtual;
procedure Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);virtual;
procedure FindFiles(Drive:PChar);
procedure SetStaticText(Drive:PChar);
procedure SetDriveInfo;
procedure WMSize(var Msg:TMessage);virtual wm_First+wm_Size;
procedure WMSetFocus(var Msg:TMessage);virtual wm_First+wm_SetFocus;
procedure IDBut1(var Msg:TMessage);virtual id_First+id_But1; {Drive}
procedure IDBut2(var Msg:TMessage);virtual id_First+id_But2; {Clipboard}
procedure IDBut3(var Msg:TMessage);virtual id_First+id_But3; {File}
procedure IDBut4(var Msg:TMessage);virtual id_First+id_But4; {Exit}
procedure IDLB2(var Msg:TMessage);virtual id_First+id_lb2;
procedure WMLButtonUp(var Msg:TMessage);virtual wm_First+wm_LButtonUp;
end;
{********************************************************************}
{M E T H O D S }
{********************************************************************}
procedure TDSApplication.InitMainWindow;
begin
MainWindow := New(PDSWindow,Init(nil,'DSize'));
end;
{********************************************************************}
{Init}
constructor TDSWindow.Init(AParent:PWindowsObject;ATitle:PChar);
begin
TWindow.Init(AParent,ATitle);
Attr.Menu := 0;
Attr.X := 20; Attr.Y := 25; Attr.W := 595; Attr.H := 325;
Editor := New(PEdit,Init(@Self,200,nil,-0,0,0,0,0,True));
with Editor^.Attr do
Style := Style or es_NoHideSel ;
Editor1 := New(PListBox,Init(@Self,id_lb2,0,0,0,0));
with Editor1^.Attr do
begin
Style := Style and not lbs_Sort ;
end;
Bn1 := New(PButton,Init(@Self,id_But1,'Drive',0,0,0,0,False));
Bn2 := New(PButton,Init(@Self,id_But2,'ClpBd',0,0,0,0,False));
Bn3 := New(PButton,Init(@Self,id_But3,'File',0,0,0,0,False));
Bn4 := New(PButton,Init(@Self,id_But4,'Exit',0,0,0,0,False));
St1 := New(PStatic,Init(@Self,id_St1,'',315,5,240,18,75));
St2 := New(PStatic,Init(@Self,id_St2,'',315,26,240,18,75));
St3 := New(PStatic,Init(@Self,id_ST3,'',310,3,250,44,75));
TheButton := LoadBitmap(HInstance,'DS_BUTTON');
TheLogo := LoadBitmap(HInstance,'DS_BMP1');
St2^.Attr.Style := St2^.Attr.Style or ss_LeftNoWordWrap;
St3^.Attr.Style := St3^.Attr.Style or ss_BlackFrame;
TheCollection := New(PDSCollection,Init(1000,100));
end;
{SetupWindow}
procedure TDSWindow.SetupWindow;
var
TheFont:HFont;
begin
TWindow.SetupWindow;
SetClassWord(HWindow,GCW_HIcon,LoadIcon(HInstance,'DS_Icon'));
TheFont := GetStockObject(OEM_Fixed_Font);
SendMessage(Editor^.HWindow,wm_Setfont,TheFont,longint(1));
SendMessage(Editor1^.HWindow,wm_Setfont,TheFont,longint(1));
SetDriveInfo;
end;
{Paint}
procedure TDSWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
var
ThePen:HPen;
TheBrush :HBrush;
OldBrush :HBrush;
OldPen:HPen;
OldBitMap:HBitMap;
MemDC :HDC;
CR:TRect;
W,H:Integer;
begin
TheBrush := GetStockObject(LtGray_Brush);
ThePen := CreatePen(ps_Solid,1,$00000000);
OldPen := SelectObject(PaintDC,ThePen);
OldBrush := SelectObject(PaintDC,TheBrush);
Rectangle(PaintDC,0,0,1024,50);
SelectObject(PaintDC,OldBrush);
SelectObject(PaintDC,OldPen);
DeleteObject(ThePen);
MemDC := CreateCompatibleDC(PaintDC);
OldBitMap := SelectObject(MemDC,TheButton);
BitBlt(PaintDC,0,0,50,50,MemDC,0,0,SrcCopy);
SelectObject(MemDC,OldBitMap);
DeleteDC(MemDC);
GetClientRect(HWindow,CR);
W := CR.Right-CR.Left;H := CR.Bottom-CR.Top;
MemDC := CreateCompatibleDC(PaintDC);
OldBitMap := SelectObject(MemDC,TheLogo);
BitBlt(PaintDC,((W div 3) - 100) div 2, {the .bmp is 100x100}
50+ ((H -50) div 2)+(((H -50) div 2)-100)div 2 ,
W div 3,H div 2,
MemDC,0,0,SrcCopy);
SelectObject(MemDC,OldBitMap);
DeleteDC(MemDC);
end;
{Done}
destructor TDSWindow.Done;
begin
DeleteObject(TheButton);
DeleteObject(TheLogo);
Dispose(TheCollection,Done);
TWindow.Done;
end;
{WMSize}
procedure TDSWindow.WMSize(var Msg:TMessage);
begin
SetWindowPos(Editor1^.HWindow,0,-1,50,(Msg.LParamLo div 3)+1,
((Msg.LParamHi-50) div 2 - 0),swp_NoZOrder);
SetWindowPos(Editor^.HWindow,0,(Msg.LParamLo div 3)-1,50,
(Msg.LParamLo * 2 div 3),(Msg.LParamHi-48),swp_NoZOrder);
SetWindowPos(Bn1^.HWindow,0,50,0,100,50,swp_NoZOrder);
SetWindowPos(Bn2^.HWindow,0,150,0,50,50,swp_NoZOrder);
SetWindowPos(Bn3^.HWindow,0,200,0,50,50,swp_NoZOrder);
SetWindowPos(Bn4^.HWindow,0,250,0,50,50,swp_NoZOrder);
end;
{WMSetFocus}
procedure TDSWindow.WMSetFocus(var Msg:TMessage);
begin
SetFocus(Editor^.HWindow);
end;
{IDBut1}
procedure TDSWindow.IDBut1(var Msg:TMessage);
begin
Dlg1 := new(PDSDialog,Init(@Self,'DS_Dlg1'));
Application^.ExecDialog(Dlg1);
if StrLen(Dlg1^.TheDrive) <> 0 then
FindFiles(Dlg1^.TheDrive);
end;
{IDBut2}
procedure TDSWindow.IDBut2(var Msg:TMessage);
var
TotChars:Integer;
begin
TotChars := Editor^.GetLineIndex(9999);
Editor^.SetSelection(0,TotChars);
Editor^.Copy;
Editor^.SetSelection(0,0);
end;
{IdBut3}
procedure TDSWindow.IDBut3(var Msg:TMessage);
const
CRLF : Array[0..2] of Char = #13#10;
EOF : Array[0..1] of Char = #26;
var
FName : Array[0..fsPathName] of Char;
Dlg :PFileDialog;
AStream: PTextStream;
ABuffer: Array[0..120] of Char;
Indx,OutCtr : Integer;
MaxPathS:Array[0..2] of Char;
wvsString:Array[0..12] of Char;
PDir :PDirRec;
begin
StrCopy(FName,'*.*');
Dlg := (New(PFileDialog,Init(@Self,PChar(sd_FileSave),FName)));
if Application^.ExecDialog(Dlg) = id_OK then
begin
if TheCollection^.MaxPath < 9 then
Str(TheCollection^.MaxPath:1,MaxPathS)
else
Str(TheCollection^.MaxPath:2,MaxPathS);
StrCat(StrCat(StrCopy(wvsString,'%-'),MaxPathS),'s');
AStream := New(PTextStream, Init(FName, stCreate,1024));
for Indx := 0 to (TheCollection^.Count - 1) do
begin
PDir := TheCollection^.At(Indx);
wvsprintf(ABuffer,wvsString,PDir^.PathName);
StrCat(ABuffer,PDir^.DirSize);
AStream^.Write(ABuffer,StrLen(ABuffer));
AStream^.Write(CRLF,2);
Inc(OutCtr);
end;
AStream^.Write(EOF,1);
Dispose(AStream, Done);
end;
end;
{IdBut4}
procedure TDSWindow.IDBut4(var Msg:TMessage);
begin
SendMessage(HWindow,wm_Close,0,0);
end;
{WMLButtonDown}
procedure TDSWindow.WMLButtonUp(var Msg:TMessage);
var
Dlg : PDialog;
begin
if (Msg.lParamLo < 50) and (Msg.lParamHi < 50) then
begin
Dlg :=New(PDialog,Init(@Self,'DS_About'));
Application^.ExecDialog(Dlg);
end;
end;
{FindFiles}
procedure TDSWindow.FindFiles(Drive:PChar);
var
SearchRec: TSearchRec;
DirBuf: array[0..fsDirectory] of Char;
PDir : PDirRec;
EName : array[0..120] of Char;
FName : array[0..120] of Char;
FMask : array[0..fsPathName] of Char;
DStack : PStack;
Item : PStackItem;
DirSize : LongInt;
szDirSize :Array[0..80] of Char;
F:File of byte;
Indx: Integer;
Buf :PChar;
Ret:LongInt;
Cursor:HCursor;
MaxP:Integer;
MaxPathS:Array[0..2] of Char;
wvsString : Array[0..12] of Char;
Count:Integer;
begin
Cursor := loadCursor(0,Idc_Wait);
SetCursor(Cursor);
Editor^.Clear;
if Drive[StrLen(Drive)-1] <> '\' then
StrCat(Drive,'\');
StrUpper(Drive);
SetCurDir(Drive);
SetStaticText(Drive);
DStack := New(PStack,Init(1000,100));
DStack^.Push(New(PStackItem,Init(Drive)));
if TheCollection^.Count > 0 then
begin
Dispose(TheCollection,Done);
TheCollection := New(PDSCollection,Init(1000,100));
end;
DirSize := 0;
MaxP := 0;
while DStack^.Count > 0 do
begin
Item := DStack^.Pop;
StrCopy(DirBuf,Item^.StackItem);
Dispose(Item,Done);
SetCurdir(Dirbuf);
if DirBuf[StrLen(DirBuf)-1] <> '\' then
StrCat(DirBuf,'\');
StrCat(StrCopy(FMask,DirBuf),'*.*');
DosError := 0;
FindFirst(FMask, faArchive+ faReadOnly+ faDirectory, SearchRec); {. dir}
while ((SearchRec.Name[0] = '.') and (DosError = 0)) do
FindNext(SearchRec);
while (DosError = 0) do
begin
if SearchRec.Attr = faDirectory then
begin
FileExpand(EName,SearchRec.Name);
if StrLen(EName) > MaxP then MaxP := StrLen(EName);
DStack^.Push(New(PStackItem,Init(EName)));
end
else {if SearchRec.Attr <> faReadOnly then }
begin
FileExpand(FName,SearchRec.Name);
Assign(F,FName);
Reset(F);
DirSize := DirSize + FileSize(F);
Close(F);
end;
Inc(Count);
FindNext(SearchRec);
end;
Str(DirSize:8,szDirSize);
TheCollection^.Insert(New(PDirRec,Init(DirBuf,szDirSize)));
DirSize := 0;
end;
GetMem(Buf,32000);
Buf[0] := #0;
wvsString[0] := #0;
MaxP := MaxP +2;
TheCollection^.MaxPath := MaxP;
if MaxP < 9 then
Str(MaxP:1,MaxPathS)
else
Str(MaxP:2,MaxPathS);
StrCat(StrCat(StrCopy(wvsString,'%-'),MaxPathS),'s');
for indx := 0 to TheCollection^.Count - 1 do
begin
PDir := TheCollection^.At(Indx);
wvsprintf(szDirsize,wvsString,PDir^.PathName);
StrCat(StrCat(StrCat(Buf,szDirSize),PDir^.DirSize),#13#10);
end;
Editor^.Insert(Buf);
Editor^.Scroll(0,-9999);
FreeMem(Buf,32000);
Dispose(DStack,Done);
Cursor := loadCursor(0,Idc_Arrow);
SetCursor(Cursor);
end;
procedure TDSWindow.SetStaticText(Drive:PChar);
var
DTotFree,DTotSize,PctUtil:Array[0..12] of Char;
DTotSizeN,DTotFreeN,PctUtilN:LongInt;
Buffer: array[0..fsDirectory] of Char;
begin
DTotFreeN := DiskFree(0);
DTotSizeN := DiskSize(0);
PctUtilN := Round(DTotFreeN / (DTotSizeN / 100)) ;
Str(DTotFreeN,DTotFree);
Str(DTotSizeN,DTotSize);
Str(PctUtilN,PctUtil);
St1^.SetText(StrCat(StrCat(StrCat(StrCopy(Buffer,'Drive '),Drive),' % Free:'),PctUtil));
St2^.SetText(StrCat(StrCat(StrCat(StrCopy(Buffer,'Free:'),DTotFree),' Total:'),DTotSize));
end;
procedure TDSWindow.SetDriveInfo;
var
Dr:Char;
ArgList : record
StrPtr : PChar;
Free:PChar;
Size:LongInt;
PctFree:LongInt;
end;
szFree:Array[0..5] of Char;
rFree:Real;
szDr:Array[0..2] of Char;
szOutput : Array[0..80] of Char;
begin
DosError := 0; StrCopy(szOutput,'');
WVSPrintf(szOutput,'Dr MBf MBt %%Free',ArgList);
Editor1^.InsertString(szOutput,-1);
Dr := 'C';
szDr[0] := Dr; szDr[1] := #0;
while DosError = 0 do
begin
SetCurDir(StrCat(szDr,':'));
if DosError = 0 then
begin
rFree := (DiskFree(0) / 1024 / 1024);
Str(rFree:4:1,szFree);
ArgList.Free := @szFree;
ArgList.Size := Round( DiskSize(0) / 1024 /1024) ;
ArgList.PctFree := Round(DiskFree(0) / (DiskSize(0) / 100 )) ;
ArgList.StrPtr := @szDr;
WVSPrintf(szOutput,'%s %s %3li %3li',ArgList);
Editor1^.InsertString(szOutput,-1);
end;
Inc(Dr);
szDr[0] := Dr;
szDr[1] := #0;
end;
end;
procedure TDSWindow.IDLB2(var Msg:TMessage);
var
szBuffer:Array[0..80] of Char;
indx:Integer;
begin
case Msg.lParamHi of
lbn_DblClk, lbn_SelChange:
begin
indx := Editor1^.GetSelIndex;
if indx > 0 then
begin
Editor1^.GetSelString(@szBuffer,80);
szBuffer[2] := #0;
FindFiles(szBuffer);
end;
Exit;
end;
end;
end;
{***********************************************************************}
procedure TDSDialog.IDLb1(var Msg:TMessage);
var
Idx : Integer;
DrBuf:Array[0..5] of Char;
Ptr : PChar;
begin
case Msg.lParamHi of
lbn_SelChange,lbn_DblClk:
begin
Ptr := TheDrive;
Idx := SendDlgItemMsg(id_Lb1,lb_GetCurSel,0,0);
SendDlgItemMsg(id_Lb1,lb_GetText,word(Idx),LongInt(Ptr));
EndDlg(Idx);
Exit;
end;
end;
end;
procedure TDSDialog.WMInitDialog(var Msg:TMessage);
var
TextItem:PChar;
Drive:Char;
DriveStr : Array[0..2] of Char;
DSN,ErrCode :Integer;
begin
TDialog.WMInitDialog(Msg);
DosError := 0;
{$I-}
Drive := 'C';
DriveStr[0] := Drive;
DriveStr[1] := #0;
TextItem := DriveStr;
while DosError = 0 do
begin
SetCurDir(StrCat(DriveStr,':'));
if DosError = 0 then
SendDlgItemMsg(id_Lb1,lb_AddString,0,LongInt(TextItem));
Inc(Drive);
DriveStr[0] := Drive;
DriveStr[1] := #0;
TextItem := DriveStr;
end;
TheDrive[0] := #0;
end;
{***********************************************************************}
constructor TStackItem.Init(NewItem:PChar);
begin
StackItem := StrNew(NewItem);
end;
destructor TStackItem.Done;
begin
StrDispose(StackItem);
end;
{***********************************************************************}
procedure TStack.Push(Item:Pointer);
begin
AtInsert(0,Item);
end;
function TStack.Pop:Pointer;
begin
Pop := At(0);
AtDelete(0);
end;
{***********************************************************************}
constructor TDirRec.Init(NewPathName:PChar;NewDirSize:PChar);
begin
PathName := StrNew(NewPathName);
DirSize := StrNew(NewDirSize);
end;
destructor TDirRec.Done;
begin
StrDispose(PathName);
StrDispose(DirSize);
end;
{***********************************************************************}
constructor TDSCollection.Init(ALimit,ADelta:Integer);
begin
TCollection.Init(ALimit,ADelta);
MaxPath := 0;
end;
function TDSCollection.Keyof(Item:Pointer):Pointer;
begin
KeyOf := PDirRec(Item)^.PathName;
end;
function TDSCollection.Compare(Key1,Key2:Pointer):Integer;
begin
Compare := StrIComp(PChar(Key1), PChar(Key2));
end;
{***********************************************************************}
{TTextStream Methods}
constructor TTextStream.Init(FileName:PChar; Mode,Size:Word);
begin
TBufStream.Init(FileName,Mode,Size);
CharsRead := 0;
CharsToRead := TBufStream.GetSize;
ARecord := MemAlloc(32000);
end;
{Done}
destructor TTextStream.Done;
begin
TBufStream.Done;
FreeMem(ARecord,32000);
end;
{GetNext}
function TTextStream.GetNext:PChar;
var
Blksize:Integer;
AChar:Char;
Indx : Integer;
IsEOR : Boolean;
begin
Indx := 0;
IsEOR := False;
ARecord[0] := #0;
while (CharsRead < CharsToRead) and (IsEOR = False) do
begin
TBufStream.Read(AChar,1);
Inc(CharsRead);
if (AChar = #13) then
begin
ARecord[Indx] := #0;
IsEOR := True;
end
else if (AChar = #10) then
begin
end
else if (AChar = #26) then
begin
end
else
begin
ARecord[Indx] := AChar;
inc(Indx);
end
end;
GetNext := ARecord;
end;
{WriteNext}
{This method not actually used due to performance loss - instead
TStream.Write is called directly}
function TTextStream.WriteNext(szARecord:PChar):Integer;
const
CRLF : Array[0..2] of Char = #13#10#0;
begin
TBufStream.Write(szARecord,
StrLen(szARecord));
TBufStream.Write(CRLF,2);
WriteNext := StrLen(szARecord);
end;
{WriteEOF}
function TTextStream.WriteEOF:Integer;
const
EOF : Array[0..1] of Char = #26;
begin
TBufStream.Write(EOF,1);
WriteEOF := 1;
end;
{IsEOF}
function TTextStream.IsEOF:Boolean;
begin
IsEOF := False;
if CharsRead >= CharsToRead then
IsEOF := True;
end;
{GetPctDone}
function TTextStream.GetPctDone:Integer;
begin
GetPctDone := CharsRead*100 div CharsToRead;
end;
{*********************************************************************}
{*** M A I N L I N E }
{*********************************************************************}
var
DSApp : TDSApplication;
begin
DSApp.Init('DSize');
DSApp.Run;
DSApp.Done;
end.